unit sound;

interface

uses
	jfunc,
	timer; { timer included for PIT constants }

const
	sound_none=0;
	sound_pcSpeaker=1;
	sound_tandy=2;
	sound_cms=3;
	sound_adlib=4;
	{
		MIDI not implemented YET, included for later use
	}
	sound_generalMidi=5;
	sound_mt32=6;

type
	tSynthLine=object
		dataStart,dataEnd,dataOffset:pChar;
		note,noteTimer,
		volume,tempo,voice,priority,
		tempoCalc:integer;
		done:boolean;
		constructor init(data:pChar; wTempo,wVoice,wPriority:word);
		procedure reset;
		procedure playStep;
	end;

var
	soundSource:integer;
	soundPort:word;

procedure startSound;
procedure killSound;
procedure outFreq(iChannel,iFreq,iLevel,iPriority:word);

implementation

type

	tVoice=record
		freq,
		priority:word;
	end;

	tCardString=record
		parm:string[10];
		description:string[32];
		scanStart,
		scanCount,
		scanInc,
		defaultPort:word;
	end;

	tCmsOctaveStore=array[0..11] of byte;

	tAdlibDualReg=array[0..1] of byte;
	tAdlibInstrument=record
		characteristics:tAdlibDualReg; { $2x }
		levelScaling:   tAdlibDualReg; { $4x }
		attackDecay:	  tAdlibDualReg; { $6x }
		sustainRelease: tAdlibDualReg; { $8x }
		waveform:       tAdlibDualReg; { $Ex }
		feedback:       byte;          { $Cx }
		extra:          array[0..5] of byte;
	end;

const
	SPK_Control=$61;
	tandyFreq=3579545;
	tandyDivider=tandyFreq/32;
	tandyIntDivider=round(tandyDivider);

	adlibLead:tAdlibInstrument=(
		characteristics:($61,$42);
		levelScaling:   ($00,$00);
		attackDecay:    ($E0,$D0);
		sustainRelease: ($FE,$DE);
		waveform:       ($01,$11);
		feedback:        $01;
		extra: ($06,$00,$00,$00,$00,$00)
	);

	cardData:array[0..6] of tCardString=(
		(
			parm:'auto';
			description:'None/AutoDetect';
			scanStart:0; scanCount:0; scanInc:0;
			defaultPort:0
		),(
			parm:'speaker';
			description:'PC Speaker';
			scanStart:0; scanCount:0; scanInc:0;
			defaultPort:$61
		),(
			parm:'tandysound';
			description:'Tandy/PCJr';
			scanStart:0; scanCount:0; scanInc:0;
			defaultPort:$C0
		),(
			parm:'cms';
			description:'CMS/Creative Game Blaster';
			scanStart:$210; scanCount:6; scanInc:$10;
			defaultPort:$220
		),(
			parm:'adlib';
			description:'Adlib';
			scanStart:0; scanCount:0; scanInc:0;
			defaultPort:$388
		),(
			parm:'gm';
			description:'General Midi';
			scanStart:$300; scanCount:5; scanInc:$10;
			defaultPort:$330
		),(
			parm:'mt32';
			description:'Roland MT32/SC100';
			scanStart:$300; scanCount:5; scanInc:$10;
			defaultPort:$330
		)
	);


	noteOffset:array[65..71] of word=(0,2,3,5,7,8,10);

	notes:array[1..84] of word=(
	{   C   C#,Db   D   D#,Eb   E     F   F#,Gb   G   G#,Ab   A   A#,Bb   B   }
		0065, 0070, 0073, 0078, 0082, 0087, 0093, 0098, 0104, 0110, 0117, 0123,
		0131, 0139, 0147, 0156, 0165, 0175, 0185, 0196, 0208, 0220, 0233, 0247,
		0262, 0277, 0294, 0311, 0330, 0349, 0370, 0392, 0415, 0440, 0466, 0494,
		0523, 0554, 0587, 0622, 0659, 0698, 0740, 0784, 0831, 0880, 0932, 0987,
		1047, 1109, 1175, 1245, 1329, 1397, 1480, 1568, 1661, 1760, 1865, 1976,
		2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
		4186, 4435, 4699, 4978, 5274, 5588, 5920, 6272, 6645, 7040, 7459, 7902
	);

	CMSFreqMap:packed array[0..127] of byte=(
		000,003,007,011,015,019,023,027,
		031,034,038,041,045,048,051,055,
		058,061,064,066,069,072,075,077,
		080,083,086,088,091,094,096,099,
		102,104,107,109,112,114,116,119,
		121,123,125,128,130,132,134,136,
		138,141,143,145,147,149,151,153,
		155,157,159,161,162,164,166,168,
		170,172,174,175,177,179,181,182,
		184,186,188,189,191,193,194,196,
		197,199,200,202,203,205,206,208,
		209,210,212,213,214,216,217,218,
		219,221,222,223,225,226,227,228,
		229,231,232,233,234,235,236,237,
		239,240,241,242,243,244,245,246,
		247,249,250,251,252,253,254,255
	);

var
	soundActive:boolean;
	voiceTable:array[0..2] of tVoice;

	cmsOctaveStore:^tCmsOctaveStore;

	oldExitProc:pointer;

procedure cmsReset; assembler;
asm
{ reset all 32 registers }
	mov  dx,soundPort
	mov  cx,1
@loopReset:
	mov  bx,cx
	mov  cx,$20
	xor  ax,ax
@loopRegisters:
	inc  dx
	out  dx,al
	inc  al
	xchg al,ah
	dec  dx
	out  dx,al
	xchg al,ah
	loop @loopRegisters

{ reset freq registers and enable sound }
	inc  dx
	mov  al,$1C
	out  dx,al
	dec  dx
	mov  al,3
	out  dx,al

	mov  cx,bx
	loop @loopReset

	les  di,cmsOctaveStore;
	mov  cx,3
	xor  ax,ax
	rep  stosw
end; { cmsReset }

procedure cmsSound(voice,freq,octave,amplitudeLeft,amplitudeRight:byte); assembler;
asm
	xor  dx,dx
	xor  ah,ah
	mov  al,voice

{
	octave registers are WRITE ONLY (stupid) so to preserve
	other voices octave settings we have to track this ourselves
	so let's get ES:DI pointed at the correct offset in our table
	ahead of time.
}
	mov  bx,ax
	shr  bx,1
	les  di,cmsOctaveStore
	add  di,bx

{
	BL = voice mod 6 = chip voice
	DX = sound card port + (voice div 6)*2
	typically $2x0 for chip 1, $2x2 for chip 2
}
	mov  bx,6
	div  bx
	mov  bx,dx  { bl now equals chip voice }
	mov  dx,soundPort
	shl  ax,1   { deterimine which chip }
	add  dx,ax

{	set amplitude }
	inc  dx     { set address register }
	mov  al,bl  { amplitudes $00..$05 }
	out  dx,al

	dec  dx     { set data register }
	mov  al,amplitudeLeft
	mov  ah,amplitudeRight
	and  al,$0F
	mov  cl,4
	shl  ah,cl
	or   al,ah
	out  dx,al

{ set frequency }
	inc  dx     { set address register }
	mov  al,bl
	or   al,$08 { frequencies $08..$0D }
	out  dx,al

	dec  dx { set data register }
	mov  al,freq
	out  dx,al

{ set octave }
	inc  dx         { set address register }
	mov  al,bl
	shr  al,1
	or   al,$10     { 2 octaves per register $10..$12 }
	out  dx,al

	dec  dx         { set data register }
	mov  al,es:[di] { read from our buffer }
	mov  ah,octave
	and  ah,$07     { just in case, mask it off }
	mov  bh,bl
	and  bh,$01
	jnz  @voiceOdd
	and  al,$F8     { voice even, mask out bottom 3 bits }
	jmp  @outOctave
@voiceOdd:
	and  al,$8F     { voice odd, mask out bits 4..6 }
	mov  cl,4
	shl  ah,cl      { and slide our octave value over }
@outOctave:
	or   al,ah      { put the two together }
	out  dx,al      { and store on card}
	mov  es:[di],al { and in buffer }

{ freq enable }
	inc  dx         { set address register }
	mov  al,$14     { channel on/off $14 bits 0..5 }
	out  dx,al

	dec  dx         { set data register }
	in   al,dx
	mov  ah,$01
	mov  cl,bl
	shl  ah,cl
	or   al,ah
	out  dx,al
end; { cmsSound }

procedure tandySound(voice:byte; tone:word; level:byte); assembler;
asm
	mov  dx,$C0

{	port[$C0]:=$80 or (voice*$20) or (tone and $0F); }
	mov  cl,voice
	mov  al,$10
	shl  al,cl
	and  al,$60
	or   al,$80
	mov  ch,al { save channel for level set }
	mov  bx,tone
	mov  ah,bl
	and  ah,$0F
	or   al,ah
	out  dx,al

{	port[$C0]:=tone shr 4; }
	mov  cl,4
	shr  bx,cl
	mov  al,bl
	out  dx,al

{	port[$C0]:=$90 or (voice*$20) or (level and $0F); }
	mov  al,level
	and  al,$0F
	or   al,ch
	or   al,$10
	out  dx,al
end;

function tandyDetect:boolean; assembler;
asm
	mov  bx,$FFFF
	mov  es,bx
	mov  di,$000E
	mov  al,$FD
	cmp  es:[di],al
	jne  @notJr
	mov  ax,bx
	ret
@notJr:
	mov  al,$FF
	cmp  es:[di],al
	jne  @notTandy
	mov  ax,$FC00
	mov  es,ax
	xor  di,di
	mov  al,$21
	cmp  es:[di],al
	jne  @notTandy
	mov  ax,bx
	ret
@notTandy:
	xor  ax,ax
end;

procedure adlibDelay(count:word); assembler;
asm
	mov cx,count
	mov dx,soundPort
@loop:
	in  al,dx
	loop @loop
end;

procedure outAdlib(register,data:byte); assembler;
asm
	mov  dx,soundPort
	mov  al,register
	out  dx,al
	mov  cx,6
@loop1:
	in   al,dx
	loop @loop1
	inc  dx
	mov  al,data
	out  dx,al
	dec  dx
	mov  cx,35
@loop2:
	in   al,dx
	loop @loop2
end;

function adlibDetect:boolean;
var
	status1,status2:boolean;
begin
	soundPort:=cardData[sound_adlib].defaultPort;
	outAdlib($04,$60);
	outAdlib($04,$80);
	if (port[soundPort] and $E0)=$00 then begin
		outAdlib($02,$FF);
		outAdlib($04,$21);
		adlibDelay(128);
		adlibDetect:=(port[soundPort] and $E0)=$C0;
		outAdlib($04,$60);
		outAdlib($04,$80);
	end else begin
		soundPort:=0;
		adlibDetect:=false;
	end;
end;

procedure adlibSetVoice(voice:byte; var instrument:tAdlibInstrument);
var
	v:word;
begin
	v:=((voice div 3) shr 3)+voice mod 3;
	with instrument do begin
		outAdlib($20+v,characteristics[0]);
		outAdlib($23+v,characteristics[1]);
		outAdlib($40+v,levelScaling[0]);
		outAdlib($43+v,levelScaling[1]);
		outAdlib($60+v,attackDecay[0]);
		outAdlib($63+v,attackDecay[1]);
		outAdlib($80+v,sustainRelease[0]);
		outAdlib($83+v,sustainRelease[1]);
		outAdlib($E0+v,waveform[0]);
		outAdlib($E3+v,waveform[1]);
		outAdlib($C0+voice,feedback);
	end;
end;


procedure adlibAllOff;
var
	t:word;
begin
	for t:=$40 to $55 do outAdlib(t,$FF);
	for t:=$B0 to $B8 do outAdlib(t,0);
end;

procedure adlibKeyOff(voice:byte);
begin
	outAdlib($B0+voice,0);
end;

procedure adlibKeyOn(voice:byte; freq:word; octave:byte);
begin
	outAdlib($A0+voice,freq and $FF);
	outAdlib($B0+voice,(
		((freq shr 8) and $03) or
		((octave and $07) shl 2) or $20
	));
end;

procedure adlibSetVolume(voice,level:byte);
begin
	outAdlib($40+voice,level and $3F);
end;

procedure adlibReset;
var
	t:word;
begin
	for t:=1 to 244 do outAdlib(t,$00);
	outAdlib(1,$20);
	outAdlib($BD,$C0);
end;

procedure speakerSound(interval:word); assembler;
asm
	mov  ax,interval
	cmp  ax,0
	jnz  @setLevel
	{ speaker off }
	in   al,SPK_Control
	and  al,$FC;
	out  SPK_Control,al
	jmp  @done
@setLevel:
  { speaker on }
	in   al,SPK_Control
	or   al,$03
	out  SPK_Control,al
	mov  al,PIT_Select2 or PIT_LSBMSB or PIT_Mode3
	out  PIT_Control,al
	mov  ax,interval
	out  PIT_Data2,al
	mov  al,ah
	out  PIT_Data2,al
@done:
end;

procedure outFreq(iChannel,iFreq,iLevel,iPriority:word);
var
	outOctave,
	outFreq,
	testPriority,
	t:word;
begin
	with voiceTable[iChannel] do begin
		freq:=iFreq;
		priority:=iPriority+1;
	end;
	case soundSource of
		sound_pcSpeaker:begin
			testPriority:=0;
			for t:=0 to 2 do with voiceTable[t] do begin
				if priority>testPriority then begin
					testPriority:=priority;
					outFreq:=freq;
				end;
			end;
			if (outFreq=0) then begin
				speakerSound(0);
			end else speakerSound(intClock8253 div outFreq);
		end;
		sound_tandy:begin
			if (iFreq>0) then begin
				tandySound(
					iChannel,
					tandyIntDivider div iFreq,
					15-iLevel
				);
			end else tandySound(iChannel,0,15);
		end;
		sound_cms:begin
			if (iFreq<32) or (iFreq>7823) or (iLevel=0) then begin
				cmsSound(iChannel,0,0,0,0);
			end else begin
				outOctave:=4;
				outFreq:=iFreq;
				while (outFreq<489) do begin
					outFreq:=outFreq*2;
					dec(outOctave);
				end;
				while (outFreq>977) do begin
					outFreq:=outFreq div 2;
					inc(outOctave);
				end;
				cmsSound(
					iChannel,
					CMSFreqMap[((outFreq-489)*128) div 489],
					outOctave,
					iLevel,iLevel
				);
			end;
		end;
		sound_adlib:begin
			if (
				(iFreq<32) or
				(iFreq>7823) or
				(iLevel=0)
			) then begin
				adlibKeyOff(iChannel);
			end else begin
				outFreq:=iFreq*2 div 3;
				outOctave:=5;
				while (outFreq>2047) do begin
					outFreq:=outFreq+2;
					inc(outOctave);
				end;
				adlibKeyOn(iChannel,outFreq,outOctave);
			end;
		end;
	end;
end;

constructor tSynthLine.init;
var
	b:byte;
begin
	b:=byte(data^);
	dataStart:=data;
	inc(dataStart);
	dataEnd:=dataStart;
	inc(dataEnd,b);
	dataOffset:=dataStart;
	tempo:=wTempo;
	voice:=wVoice;
	priority:=wPriority;
	tempoCalc:=900 div tempo; { max accuracy 32th notes... kinda }
	reset;
end;

procedure tSynthLine.reset;
begin
	dataOffset:=dataStart;
	volume:=32;
	noteTimer:=0;
	done:=false;
	outFreq(voice,0,0,0);
end;

procedure tSynthLine.playStep;
begin
	if (noteTimer>0) then begin
		dec(noteTimer);
	end else if not(dataOffset=dataEnd) then begin
		case dataOffset^ of
			'0'..'9':begin
				note:=(ord(dataOffset^)-48)*12-3;
				inc(dataOffset);
				case dataOffset^ of
					'A'..'G':begin
						note:=note+noteOffset[ord(dataOffset^)];
						inc(dataOffset);
						if (dataOffset^='#') then begin
							inc(note);
							inc(dataOffset);
						end;
						if (dataOffset^='b') then begin
							dec(note);
							inc(dataOffset);
						end;
						case dataOffset^ of
							'0'..'9':noteTimer:=(ord(dataOffset^)-48)*tempoCalc-1;
							'A'..'Z':noteTimer:=(ord(dataOffset^)-55)*tempoCalc-1;
							'a'..'z':noteTimer:=(ord(dataOffset^)-87)*tempoCalc-1;
						end;
						inc(dataOffset);
						if (note>0) and (note<85) then begin
							note:=notes[note];
							outFreq(voice,note,volume,priority);
						end else outFreq(voice,0,0,0);
					end;
				end;
			end; { note }
			'v','V':begin
				inc(dataOffset);
				case dataOffset^ of
					'0'..'9':volume:=(ord(dataOffset^)-48);
					'A'..'F':volume:=(ord(dataOffset^)-55);
					'a'..'f':volume:=(ord(dataOffset^)-87);
					else volume:=0;
				end;
				outFreq(voice,note,volume,priority);
				inc(dataOffset);
			end; { volume }
			'r','R':begin
				outFreq(voice,0,0,0);
				inc(dataOffset);
				case dataOffset^ of
					'0'..'9':noteTimer:=(ord(dataOffset^)-48)*tempoCalc-1;
					'A'..'Z':noteTimer:=(ord(dataOffset^)-55)*tempoCalc-1;
					'a'..'z':noteTimer:=(ord(dataOffset^)-87)*tempoCalc-1;
				end;
				inc(dataOffset);
			end; { rest }
		end; { case }
		if dataOffset^=',' then inc(dataOffset);
	end else if not(done) then begin
		outFreq(voice,0,0,0);
		done:=true;
	end;
end;

procedure startSound;
var
	t:integer;
	d:word;
begin
	for t:=0 to 2 do with voiceTable[t] do begin
		freq:=1;
		priority:=0;
	end;
	case soundSource of
		sound_tandy:asm
			{ 1k/jr }
			mov  ax,$8003
			int  $1A
			{ manually set for older machines just in case }
			mov  al,$6C
			out  $61,al
			mov  ax,$8003
			int  $1A
		end;
		sound_cms:cmsReset;
		sound_adlib:begin
			adlibReset;
			adlibSetVoice(0,adlibLead);
			adlibSetVoice(1,adlibLead);
			adlibSetVoice(2,adlibLead);
		end;
	end;
	soundActive:=true;
end;

procedure killSound;
begin
	case soundSource of
		sound_pcSpeaker:asm
			{ speaker off }
			in   al,SPK_Control
			and  al,$FC;
			out  SPK_Control,al
		end;
		sound_tandy:asm
			mov  dx,$C0
			mov  al,$9F
			out  dx,al
			mov  al,$BF
			out  dx,al
			mov  al,$DF
			out  dx,al
		end;
		sound_cms:cmsReset;
		sound_adlib:begin
			adlibAllOff;
			adlibReset;
		end;
	end;
	soundActive:=false;
end;

procedure safeExit; far;
begin
	if soundActive then killSound;
	case soundSource of
		sound_cms:dispose(cmsOctaveStore);
	end;
	exitProc:=oldExitProc;
end;

function forceSound:boolean;
var
	t,n,b:word;
	st:string[4];
begin
	soundSource:=0;
	t:=4;
	repeat
		dec(t);
		with cardData[t] do begin
			if paramExists('/'+parm) then begin
				soundSource:=t;
				soundPort:=defaultPort;
				t:=0;
			end else if (scanCount>0) then begin
				n:=scanCount;
				b:=scanStart;
				repeat
					st:=word2hex(b);
					st[1]:=':';
					if paramExists('/'+parm+st) then begin
						soundSource:=t;
						soundPort:=b;
						n:=0;
						t:=0;
					end;
					b:=b+scanInc;
					dec(n);
				until n=0;
			end;
		end;
	until t<=0;
	forceSound:=(soundSource>0);
end;

procedure writeSource;
var
	st:string[4];
begin
	writeln('Sound Card: ',cardData[soundSource].description);
	st:=word2hex(soundPort);
	st[1]:='x';
	writeln('Base Port: 0',st);
end;

begin
	soundActive:=false;
	if not(forceSound) then begin
		writeln('Autodetecting Sound');
		if adlibDetect then begin
			soundSource:=sound_adlib;
			soundPort:=cardData[sound_adlib].defaultPort;
		end else if tandyDetect then begin
			soundSource:=sound_tandy;
			soundPort:=cardData[sound_tandy].defaultPort;
		end else begin
			soundSource:=sound_pcSpeaker;
			soundPort:=cardData[sound_pcSpeaker].defaultPort;
		end;
	end;
	writeSource;
	case soundSource of
		sound_cms:new(cmsOctaveStore);
	end;
	oldExitProc:=exitproc;
	exitproc:=@safeExit;
end.